MacWorld 1999 March - Disc 1/Macworld (1999-03) (Disk 1).dmg/Shareware World/Utilities/Text Processing/Alpha/Tcl/Completions/PerlCompletions.tcl

Text File | 1998-08-13 | 5.5 KB | 148 lines | [TEXT/ALFA]

##
 # This    file will be sourced automatically, immediately after
 # the _first_ time    the    file which defines its mode is sourced.
 # Use this file to declare completion items and procedures
 # for this mode.
 #
 # Some common defaults are included below.
 ##

set Perlcmds { ARGV BEGIN accept alarm atan2 autoflush binmode bless
caller chdir chmod chomp chown chroot close closedir connect continue crypt
dbmclose dbmopen defined delete elsif endgrent endhostent endnetent
endprotoent endpwent endservent exists fcntl fileno flock foreach
format_formfeed format_line_break_characters format_lines_left
format_lines_per_page format_name format_page_number format_top_name
formline getgrent getgrgid getgrnam gethostbyaddr gethostbyname gethostent
getlogin getnetbyaddr getnetbyname getnetent getpeername getpgrp getppid
getpriority getprotobyname getprotobynumber getprotoent getpwent getpwnam
getpwuid getservbyname getservbyport getservent getsockname getsockopt
gmtime import index input_line_number input_record_separator ioctl lcfirst
length listen local localtime lstat mkdir msgctl msgget msgrcv msgsnd
opendir output_field_separator output_record_separator package print printf
quotemeta readdir readlink rename require reset return reverse rewinddir
rindex rmdir scalar seekdir select semctl semget semop setgrent sethostent
setnetent setpgrp setpriority setprotoent setpwent setservent setsockopt
shift shmctl shmget shmread shmwrite shutdown sleep socket socketpair
splice split sprintf srand study substr symlink syscall sysread system
syswrite telldir times truncate ucfirst umask undef unless unlink unpack
unshift untie until utime values waitpid wantarray while write }

set completions(Perl) {contraction completion::cmd Electric Var}

set Perlelectrics(for) " (•start•;•test•;•increment•)\{\n\t•body•\n\}\n••"
set Perlelectrics(foreach) "$•scalar• (@•array•)\{\n\t•body•\n\}\n••"
set Perlelectrics(while) " (@•array•)\{\n\t•body•\n\}\n••"
set Perlelectrics(if) " (•condition•)\{\n\t•body•\n\} ••"
set Perlelectrics(else) " \{\n\t•else body•\n\} ••"
set Perlelectrics(elsif) " (•condition•)\{\n\t•else body•\n\} ••"
set Perlelectrics(do) " \{••\n\t••\n\} while (•test•);\n••"

# alternative defs of above -trf
set Perlelectrics(while) " (•test•) \{\r\t•body•\r\}\r••"
set Perlelectrics(foreach) " \$•loopVar• (•listReturner•) \{\r\t•body•\r\}\r••"

# ◊◊◊◊ functions ◊◊◊◊ #
set Perlelectrics(split) "(\"•at-these-chars•\", •string-returner•)••"

# ◊◊◊◊ contractions ◊◊◊◊ #
set Perlelectrics(o'd) "◊kill0open(•hndlName•, \"•fileName•\") or die \"Can't open •fileName•: $!\"\n"

# ◊◊◊ bind ◊◊◊◊ #
bind 0x15 <z> Perl::addRemoveDollars Perl
bind 0x13 <z> Perl::addRemoveHashSymbol Perl


proc Perl::addRemoveDollars {} {
        set p [getPos]
        backwardWord
        if {[lookAt [expr [getPos] ]] == "\$"} {
                forwardChar
                backSpace
                goto [expr $p -1]
        } else {
                insertText "\$"
                goto [expr $p +1]
        }
}


proc Perl::addRemoveHashSymbol {} {
        set p [getPos]
        backwardWord
        if {[lookAt [expr [getPos] ]] == "@"} {
                forwardChar
                backSpace
                goto [expr $p -1]
        } else {
                insertText "@"
                goto [expr $p +1]
        }
}


##
 # -------------------------------------------------------------------------
 #
 #    "Perl::Completion::Var" --
 #
 #     A mildly adaptive call    of completion::word, in which    we realise we
 #     should    complete '$abc...' if we can only see 'abc...'.     The standard
 #     procedure consider    '$'    to be part of a    word so    that would otherwise
 #     fail.  Also handles '%', '@' and '*'.
 # -------------------------------------------------------------------------
 ##
proc Perl::Completion::Var {dummy} {
    global completion::in_progress_pos completion_got completion_looking

    # cursor changed place?
    set pos [getPos]
    if {$pos==${completion::in_progress_pos}} {
        return [completion::update Perl::Completion::Var $completion_got $completion_looking]
    }

    set lastword [completion::lastWord]
    if [containsSpace $lastword] {return 0}
    set possPrefix [string index $lastword 0]
    if {[string first $possPrefix "\$%@*"] != -1 } {
        set completion_got [string range $lastword 1 end]
        set completion_looking $completion_got
        return [completion::update Perl::Completion::Var $completion_got $completion_looking]
    } else {
        return [completion::update completion::word]
    }
}

##
 # -------------------------------------------------------------------------
 #
 # "identifiersToScrap_Perl" --
 #
 #  This is useful when you want to check for spelling mistakes in identifiers
 #  (can be used with "cannonize"). Also, provides a handy way to make all the
 #  identifiers available to another file so you can use the completion/expansion
 #  routines. Just paste them in whatever file you like. (Invoke from command line)
 # -------------------------------------------------------------------------
 ##
proc identifiersToScrap_Perl {} {
    set id_pat {([$@%*]\w+)|(<\w+>)}
    set pos 0
    while {![catch {search -s -f 1 -r 1 -m 0 -i 0 $id_pat $pos} res]} {
        append idents [eval getText $res] " "
        set pos [expr [lindex $res 1] +1]
    }
    if {[info exist idents]} {
        set idents [lunique $idents]
        set idents [lsort -command sortByIgnoringFirstChar $idents]
        regsub -all {\{} $idents "" idents
        regsub -all {\}} $idents "" idents
#         regsub -all {\{([^\}])*\}} $idents "" idents
        putScrap "# $idents"
    }

}

proc sortByIgnoringFirstChar {one two} {
    string compare [string tolower [string range $one 1 end]] \
      [string tolower [string range $two 1 end]]
}